home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Utilities / Miscellaneous / CopyPaste 3.3.4 / CopyPaste Tools Sourcecode / EdressExtractor / EdressExtractor.p < prev    next >
Encoding:
Text File  |  1997-06-06  |  3.5 KB  |  139 lines  |  [TEXT/CWIE]
  1. {•This sourcecode is an example for creating a FKey coderesource with•}
  2. {•Metrowerks Pascal. It is copyrighted by Peter Hoerster and released•}
  3. {•for free use in any Shareware or Freeware product as a way to thank all•}
  4. {•programmers who share code snippets. You may put this sources on any•}
  5. {•CD ROM or any Archive Server but you may not sell it. •}
  6.  
  7. {• For comments please write to <hoerster@muenster.de>•}
  8.  
  9.  
  10.  
  11.  
  12.  
  13. unit EdressExtractor;
  14. interface
  15.  
  16.     uses
  17.         Types, OSUtils, GestaltEqu, Script, notification, Resources, Events,PascalA4,
  18.           QuickDraw, ToolUtils, Memory, LowMem, Scrap; 
  19.  
  20. {$MAIN}
  21.                         
  22.     procedure main;        
  23.  
  24. implementation
  25.  
  26.     const
  27.         step = 1000;
  28.         semikolon = ';';
  29.         komma = ',';
  30.         colon = ':';
  31.         space = ' ';
  32.         openbracket = '<';
  33.         closebracket = '>';
  34.         tab = char(ord(9));
  35.         esc = char(ord(27));
  36.         Enter = char(ord(3));                                {the enter character}
  37.         Return = char(ord(13));                                {the return character}
  38.  
  39.  
  40. procedure Fillthearray(myclipHandle: handle;resulthdl:handle; myclipsize: longint);
  41.     type
  42.             chararray=packed array[1..1]of char;
  43.             charptr=^chararray;
  44.             charhdl=^charptr;
  45.         var
  46.             charcount, startposition: longint;
  47.             count: longint;
  48.             readbuffer: str63;
  49.             myerr:oserr;
  50.             done, found: boolean;
  51.     begin
  52.         readbuffer := 'o';
  53.         done := false;
  54.         startposition := 0;
  55.         count := 0;
  56.         repeat
  57.             count := count+1;
  58.             if count>myclipsize then
  59.                 done:=true
  60.             else
  61.                 begin
  62.                     //readbuffer[1]:=charhdl(myclipHandle)^^[count];
  63.                     if (ord(char(charhdl(myclipHandle)^^[count]))<45)|
  64.                     ((ord(char(charhdl(myclipHandle)^^[count]))>57) & (ord(char(charhdl(myclipHandle)^^[count]))<64)) then
  65.                     
  66.                          startposition:=count;
  67.                     if (charhdl(myclipHandle)^^[count] = '@') then
  68.                         begin
  69.                             count:= startposition;
  70.                             found := false;
  71.                             charcount := 0;
  72.                             repeat
  73.                                 charcount := charcount + 1;
  74.                                 count:=count+1;
  75.                                 
  76.                                 {if (readbuffer[1] in [space, tab, enter, return,
  77.                                 openbracket, closebracket, semikolon, komma, colon]) then}
  78.                                 if (ord(char(charhdl(myclipHandle)^^[count]))<45)|
  79.                                 ((ord(char(charhdl(myclipHandle)^^[count]))>57) & (ord(char(charhdl(myclipHandle)^^[count]))<64)) then
  80.                                     found := true
  81.                             until found | (charcount > 50);
  82.                             if found=true then
  83.                                 begin
  84.                                     readbuffer[0]:=char(ord(charcount));
  85.                                     blockmove( pointer(ord4(myclipHandle^)+startposition),@readbuffer[1],charcount-1);
  86.                                     readbuffer[charcount] := return;
  87.                                     if pos('.',readbuffer)>0 then
  88.                                         myerr:=PtrAndHand(@readbuffer[1],resulthdl,charcount);
  89.                                     readbuffer := 'o';
  90.                                 end;
  91.                             startposition:=count;
  92.                         end;
  93.                 end;
  94.         until (done);
  95.     end;
  96.  
  97. procedure dopaste;
  98.     const
  99.         pastecode=2422;
  100.     var 
  101.         qel: EvQelPtr;
  102.     begin
  103.             if ppostevent(3, pastecode, qel) = noerr then
  104.             qel^.evtqmodifiers := cmdkey;
  105.     end;
  106.  
  107.  
  108.     procedure main;
  109.         var
  110.             oldA4: LongInt;
  111.             myerr:oserr;
  112.             myclipsize,templongint: longint;
  113.             myclipHandle: handle;
  114.             resulthdl:handle;
  115.     begin
  116.         oldA4 := SetCurrentA4;
  117.         myclipsize := GetScrap(nil, 'TEXT', templongint);
  118.         resulthdl:=newhandlesys(0);
  119.         mycliphandle := Tempnewhandle(myclipsize,myerr);
  120.         
  121.         if memerror=noerr then 
  122.             begin
  123.                 myclipsize := GetScraP(myclipHandle, 'TEXT', templongint);
  124.                 if myclipsize > 0 then
  125.                     begin
  126.                         Fillthearray(myclipHandle,resulthdl,myclipsize);
  127.                         hlock(resulthdl);
  128.                         myerr := ZeroScrap;
  129.                         myerr := putscrap(gethandlesize(resulthdl), 'TEXT', resulthdl^);
  130.                         hunlock(resulthdl);
  131.                         dopaste;
  132.                     end;
  133.             end;
  134.         TempDisposeHandle(myCliphandle,myerr);
  135.         oldA4 := SetA4(oldA4);
  136.     end;
  137. end.
  138.  
  139.